home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / graphics / fig2mfpic / graphbase.mf < prev    next >
Text File  |  1994-06-15  |  23KB  |  1,229 lines

  1. %%% Author: Geoffrey Tobin.
  2. %%% Address: G.Tobin@ee.latrobe.edu.au
  3. %%%
  4. %%%  File: graphbase.mf
  5. %%%
  6.  
  7. mode_setup;
  8. message "graphbase 0.2 fig 2a - 13:32 GMT +10 Thu 16 June 1994";
  9.  
  10. % set up local environment
  11.  
  12. def mfpicenv =
  13. begingroup
  14.  
  15. % miscellaneous utilities
  16.  
  17. % gt - op_pair operates with "op"
  18. % on both parts of a pair p.
  19.  
  20. save op_pair;
  21.  
  22. vardef op_pair (text op) (expr p) =
  23.   (op (xpart p), op (ypart p))
  24. enddef;
  25.  
  26. save floorpair, ceilingpair;
  27.  
  28. def floorpair = op_pair (floor) enddef;
  29. def ceilingpair = op_pair (ceiling) enddef;
  30.  
  31. % gt - Should there be more error-checking,
  32. % eg of types, in these utility routines?
  33. % That would slow them down.
  34.  
  35. % gt - textpairs converts the text t into the
  36. % array of n pairs, pts, that it contains.
  37.  
  38. save textpairs;
  39.  
  40. def textpairs (text t) (suffix pairs_, n_) =
  41.  n_ := 0;
  42.  for q=t:
  43.   pairs_[incr n_] := q;
  44.  endfor;
  45. enddef;
  46.  
  47. % gt - Watch out!  Need to ensure that "p_", etc.,
  48. % don't clash with any name in the passed text "t".
  49. % That's a nasty error to trace!
  50. %
  51. % A name conflict between local variables and variables
  52. % in a text parameter is especially likely in low-level
  53. % utility macros, such as minpair, maxpair and corner.
  54. %
  55. % Unfortunately, we can't *ensure* it won't happen.
  56. % So I appended the underscore to reduce the
  57. % probability of that happening.
  58. %
  59. % Evidently that's why Knuth uses "u_" in "max" and
  60. % "min" in "plain.mf".
  61.  
  62. % gt - corner may be used for finding
  63. % a corner of the bounding box of the
  64. % set of points listed in u and t.
  65. % Other uses may be imaginable. (?)
  66.  
  67. save corner;
  68.  
  69. vardef corner (text xop) (text yop)
  70.               (expr u)(text t) =
  71.   save p_;
  72.   pair p_;
  73.   p_ := u;
  74.   for q=t:
  75.     p_ := (xop (xpart p_, xpart q),
  76.        yop (ypart p_, ypart q));
  77.   endfor;
  78.   p_
  79. enddef;
  80.  
  81. % gt - bottom right, bottom right,
  82. % top left, top right corners.
  83.  
  84. save blpair, brpair, tlpair, trpair;
  85.  
  86. def blpair = corner (min) (min) enddef;
  87. def brpair = corner (max) (min) enddef;
  88. def tlpair = corner (min) (max) enddef;
  89. def trpair = corner (max) (max) enddef;
  90.  
  91. def minpair = blpair enddef;
  92. def maxpair = trpair enddef;
  93.  
  94. % setup
  95. % gt - sets the graphics coordinates.
  96.  
  97. save bounds,
  98.   xneg,xpos,yneg,ypos;
  99.  
  100. def bounds(expr a,b,c,d) =
  101.  xneg:=a;
  102.  xpos:=b;
  103.  yneg:=c;
  104.  ypos:=d;
  105. enddef;
  106.  
  107. % conversion
  108.  
  109. save xconv;
  110.  
  111. def xconv(expr xvalue) =
  112.  ((xvalue-xneg)/(xpos-xneg))*w
  113. enddef;
  114.  
  115. save unxconv;
  116.  
  117. def unxconv(expr pvalue) =
  118.  ((pvalue/w)*(xpos-xneg)+xneg)
  119. enddef;
  120.  
  121. save yconv;
  122.  
  123. def yconv(expr yvalue) =
  124.  ((yvalue-yneg)/(ypos-yneg))*h
  125. enddef;
  126.  
  127. save ztr;
  128.  
  129. transform ztr;
  130.  
  131. save setztr;
  132.  
  133. def setztr =
  134.  ztr:=identity
  135.  shifted -(xneg,yneg)
  136.  xscaled (w/(xpos-xneg))
  137.  yscaled (h/(ypos-yneg));
  138. enddef;
  139.  
  140. % pen width
  141. % in pixel coordinates
  142.  
  143. save penwd;
  144. newinternal penwd;
  145. interim penwd := 0.5pt;
  146.  
  147. % arrowheads
  148. % in pixel coordinates
  149.  
  150. % hdwdr = arrowhead's ratio of width to length,
  151. % hdten = tension used in drawing its barbs.
  152.  
  153. save hdwdr, hdten;
  154. newinternal hdwdr, hdten;
  155. interim hdwdr := 1;
  156. interim hdten := 1;
  157.  
  158. % draw an arrowhead.
  159.  
  160. save head, p,side;
  161.  
  162. def head(expr front, back, width, t) =
  163.  pair p[], side;
  164.  side := (width/2) *
  165.    ((front-back) rotated 90);
  166.  p1 := back + side;
  167.  p2 := back - side;
  168.  draw front{back-front}..tension t..p1;
  169.  draw front{back-front}..tension t..p2;
  170. enddef;
  171.  
  172. % draw an arrowhead of length hlen
  173. % for a path f.
  174.  
  175. save headpath, p;
  176.  
  177. def headpath(expr f,hlen) =
  178.  pair p[];
  179.  p2:=point infinity of f;
  180.  p1:=direction infinity of f;
  181.  if p1<>(0,0):
  182.   head(p2,p2-(hlen*unitvector(p1)),
  183.     hdwdr,hdten);
  184.  fi;
  185. enddef;
  186.  
  187. % shading and hatching routines
  188. % in pixel coordinates
  189.  
  190. % gt - modified onedot based on
  191. % plain metafont's "drawdot".
  192. % Used in stipple shading.
  193. %
  194. % Note:
  195. % currentpen_path, def_pen_path_,
  196. % t_, and penspeck are defined
  197. % in plain metafont ("plain.mf"
  198. % or "plain.base").
  199.  
  200. save onedot;
  201.  
  202. def onedot(expr p)(suffix v) =
  203.   if unknown currentpen_path:
  204.     def_pen_path_
  205.   fi;
  206.   addto v
  207.     contour currentpen_path
  208.     shifted p.t_
  209.     withpen penspeck
  210. enddef;
  211.  
  212. % gt - draw path f in picture v.
  213. % ("onepath" is the old "onedot",
  214. % but f is intended to be a general path.)
  215. % Used, eg, in hatching and in drawpaths.
  216.  
  217. save onepath;
  218.  
  219. def onepath (expr f) (suffix v) =
  220.   addto v doublepath f
  221.     withpen currentpen;
  222. enddef;
  223.  
  224. % gt - Paths must be continuous - I think
  225. % - but using suffix, we can pass arrays
  226. % of paths.
  227. %
  228. % My eventual goal is to do as much as
  229. % feasible, and memory-affordable, in
  230. % graphics coordinates, so we can rotate
  231. % and otherwise transform sets of paths
  232. % before drawing.
  233.  
  234. % gt - draw the n paths f[] in picture v.
  235.  
  236. save drawpaths;
  237.  
  238. def drawpaths (expr n) (suffix f, v) =
  239.   for i=1 upto n:
  240.     onepath (f[i], v);
  241.   endfor;
  242. enddef;
  243.  
  244. % clip picture v to interior of path f.
  245.  
  246. save clip;
  247.  
  248. vardef clip(expr f)(suffix v) =
  249.  save vt;
  250.  picture vt;
  251.  vt:=v;
  252.  cull vt keeping (1,infinity);
  253.  addto vt contour f;
  254.  cull vt keeping (2,infinity);
  255.  vt
  256. enddef;
  257.  
  258. % gt - find bounding box of path f.
  259.  
  260. save boundingbox, p;
  261.  
  262. def boundingbox (expr f) (suffix ll, ur) =
  263.   ur := ll := point 0 of f;
  264.   pair p[];
  265.   for i=0 upto length f:
  266.     p0 := point i of f;
  267.     p1 := precontrol i of f;
  268.     p2 := postcontrol i of f;
  269.     ll := minpair (ll, p0, p1, p2);
  270.     ur := maxpair (ur, p0, p1, p2);
  271.   endfor;
  272. enddef;
  273.  
  274. % gt - shading.
  275.  
  276. % gt - I'm not so happy with dot densities
  277. % over a uniform range.
  278. % Here's code to approximate what may
  279. % be the human eye's light sensitivity.
  280. %
  281. % Mind you, this sort of stuff is done much
  282. % faster in C.
  283.  
  284. save exp;
  285.  
  286. vardef exp (expr x) =
  287.   mexp (256 * x)
  288. enddef;
  289.  
  290. % graya scales the spacing sp;
  291. % grayb scales the graylevel g.
  292.  
  293. save graya, grayb;
  294.  
  295. newinternal graya, grayb;
  296.  
  297. % initial values of gray parameters.
  298.  
  299. interim graya := 0.5 pt;
  300. interim grayb := 3/20;
  301.  
  302. % setgraypars sets gray parameters.
  303. % experimentation is recommended.
  304.  
  305. save setgraypars;
  306.  
  307. def setgraypars (expr a, b) =
  308.   graya := a;
  309.   grayb := b;
  310. enddef;
  311.  
  312. % gt - grayspace gives the dot spacing
  313. % for graylevel g.
  314. %
  315. % Not sure how this model performs.
  316.  
  317. save grayspace;
  318.  
  319. vardef grayspace (expr g) =
  320.   if g <= 1:  % white
  321.     infinity
  322.   elseif g >= 21:  % black
  323.     0
  324.   else:  % gray
  325.     graya / (1 - exp (-g * grayb))
  326.   fi
  327. enddef;
  328.  
  329. % gt - stipple upright box with lower left
  330. % at ll, upper right at ur, in picture v;
  331. % 2sp is dot spacing (rows offset by sp).
  332. %
  333. % NB: "stipple" means "shade with dots",
  334. % if I understand my English dictionary.
  335. %
  336. % Thomas Leathrum devised the trick whereby
  337. % the dots are arranged on a regular grid
  338. % of mesh size sp by sp with the pixel
  339. % origin as one crosspoint.  This ensures
  340. % that objects shaded with the same stipple
  341. % density may be cleanly overlaid.
  342.  
  343. save shadebox, sll, mn, m, n, twosp, p;
  344.  
  345. def shadebox (expr sp, ll, ur) (suffix v) =
  346.   pair sll;
  347.   sll:=sp*(ceilingpair(ll/sp));
  348.   pair mn;
  349.   mn:=floorpair((ur-sll)/sp);
  350.   m:=xpart mn;
  351.   n:=ypart mn;
  352.   twosp:=2sp;
  353.   v:=nullpicture;
  354.   pair p[];
  355.   p2:=sll;
  356.   for i=0 upto m:
  357.     p3:=p2 if odd i: +(0,sp) fi;
  358.     for j=0 upto n:
  359.       if (not odd (i+j)):
  360.         onedot (p3, v);
  361.         p3:=p3+(0,twosp);
  362.       fi;
  363.     endfor;
  364.     p2:=p2+(sp,0);
  365.   endfor;
  366. enddef;
  367.  
  368. % stipple interior of closed path f;
  369. % if spacing not positive, fill.
  370.  
  371. save shadepath, ll, ur, v;
  372.  
  373. def shadepath (expr sp, f) =
  374.  if not cycle f: ;
  375.  elseif sp<=0:
  376.    fill f;
  377.  elseif sp < infinity:
  378.    pair ll, ur;
  379.    boundingbox (f, ll, ur);
  380.    picture v;
  381.    shadebox (sp, ll, ur, v);
  382.    addto currentpicture
  383.      also clip(f,v);
  384.  fi;
  385. enddef;
  386.  
  387. % gt - hatch an upright box in picture v,
  388. % with line separation sep x sep.
  389. %
  390. % Notice the similarity to shadebox.
  391.  
  392. save hatchbox, llx, lly, urx, ury, sll,
  393.      mn, m, n, f;
  394.  
  395. def hatchbox (expr sep, ll, ur) (suffix v) =
  396.   llx := xpart ll;
  397.   lly := ypart ll;
  398.   urx := xpart ur;
  399.   ury := ypart ur;
  400.   pair sll;
  401.   sll := sep * ceilingpair (ll/sep);
  402.   pair mn;
  403.   mn := floorpair ((ur-sll)/sep);
  404.   m := xpart mn;
  405.   n := ypart mn;
  406.   v := nullpicture;
  407.   path f;
  408.   f := (xpart sll, lly)--(xpart sll, ury);
  409.   for i=0 upto m:
  410.     onepath (f, v);
  411.     f := f translated (sep, 0);
  412.   endfor;
  413.   f := (llx, ypart sll)--(urx, ypart sll);
  414.   for j=0 upto n:
  415.     onepath (f, v);
  416.     f := f translated (0, sep);
  417.   endfor;
  418. enddef;
  419.  
  420. save hatchpath, ll, ur, v;
  421.  
  422. def hatchpath (expr sep, f) =
  423.  if not cycle f: ;
  424.  elseif sep<=0:
  425.    fill f;
  426.  elseif sep < infinity:
  427.    pair ll, ur;
  428.    boundingbox (f, ll, ur);
  429.    picture v;
  430.    hatchbox (sep, ll, ur, v);
  431.    addto currentpicture
  432.      also clip (f, v);
  433.  fi;
  434. enddef;
  435.  
  436. % gt - shading & hatching macros
  437. % with a syntax like draw, fill,
  438. % unfill and erase.
  439. % sp, sep are in pixel coords,
  440. % f in graphics coordinates;
  441. % f is transformed transparently.
  442.  
  443. save shade;
  444.  
  445. def shade (expr sp) expr f =
  446.   shadepath (sp, f transformed ztr);
  447. enddef;
  448.  
  449. save hatch;
  450.  
  451. def hatch (expr sep) expr f =
  452.   hatchpath (sep, f transformed ztr);
  453. enddef;
  454.  
  455. % gt - common combinations.
  456.  
  457. save drawshade;
  458.  
  459. def drawshade (expr sp) expr f =
  460.   draw f transformed ztr;
  461.   shade (sp) f;
  462. enddef;
  463.  
  464. save drawhatch;
  465.  
  466. def drawhatch (expr sep) expr f =
  467.   draw f transformed ztr;
  468.   hatch (sep) f;
  469. enddef;
  470.  
  471. % * rest of macros start in graphing
  472. % coordinates but convert to pixel
  473. % to draw
  474. % * variables ending in "_px"
  475. % converted to pixel
  476. % * exceptions are the TeX dimensions
  477. % here called:
  478. % ptwd, hlen, dlen, slen, len, sp, sep
  479. % all of which are in pixel coordinates
  480. % * macros beginning with "mk" operate
  481. % entirely in graphing coordinates
  482.  
  483. % general path construction
  484.  
  485. save mkpath;
  486.  
  487. vardef mkpath(expr smooth, cyclic, n)
  488.   (suffix pts) =
  489.  if smooth:
  490.   if cyclic:
  491.    pts[1]{pts[2]-pts[n]}
  492.   else:
  493.    pts[1]
  494.   fi
  495.   for i=2 upto n-1:
  496.    ..pts[i]{pts[i+1]-pts[i-1]}
  497.   endfor
  498.   if cyclic:
  499.    ..pts[n]{pts[1]-pts[n-1]}..cycle
  500.   else:
  501.    ..pts[n]
  502.   fi
  503.  else:
  504.   for i=1 upto n-1:
  505.     pts[i] --
  506.   endfor
  507.   pts[n]
  508.   if cyclic:
  509.    -- cycle
  510.   fi
  511.  fi
  512. enddef;
  513.  
  514. % points, lines, and arrows
  515.  
  516. save pointd, p;
  517.  
  518. def pointd(expr a,ptwd) =
  519.  pair p_px;
  520.  p_px:=a transformed ztr;
  521.  fill fullcircle scaled ptwd shifted p_px;
  522. enddef;
  523.  
  524. save line;
  525.  
  526. def line(expr a,b) =
  527.  draw (a..b) transformed ztr;
  528. enddef;
  529.  
  530. % gt - arrowpath draws path f
  531. % with an arrowhead;
  532. % hlen is in pixel coordinates;
  533. % f is in graphics coords;
  534. % f is transformed transparently.
  535. % Compare shade, hatch, etc.,
  536. % and contrast shadepath.
  537.  
  538. save arrowpath, f_px;
  539.  
  540. def arrowpath (expr hlen) expr f =
  541.   path f_px;
  542.   f_px := f transformed ztr;
  543.   draw f_px;
  544.   headpath (f_px, hlen);
  545. enddef;
  546.  
  547. % gt - arrow now uses arrowpath.
  548.  
  549. save arrow;
  550.  
  551. def arrow(expr tl,hd,hlen) =
  552.  arrowpath (hlen) tl..hd ;
  553. enddef;
  554.  
  555. % gt - "px" was too frequent
  556. % in dottedline, and made the code
  557. % hard to read, so I've deleted it.
  558. % Only a and b are in graphics coords.
  559.  
  560. save dottedline,
  561.   p, v, l, delta, n;
  562.  
  563. def dottedline (expr a, b, dlen, slen) =
  564.   pair p[];
  565.   p1 := a transformed ztr;
  566.   p3 := b transformed ztr;
  567.   l := length (p3-p1);
  568.   if (l > 2dlen) and
  569.     (dlen >= 0) and (slen >= 0):
  570.   else:
  571.     pair v;
  572.     v := unitvector (p3-p1);
  573.     n := floor ((l+slen-dlen) / (dlen+slen));
  574.     delta := (l-dlen) / n - (dlen+slen);
  575.     for i=1 upto n:
  576.       p2 := p1 + dlen * v;
  577.       draw p1..p2;
  578.       p1 := p2 + (slen+delta) * v;
  579.     endfor;
  580.   fi;
  581.   draw p1..p3;
  582. enddef;
  583.  
  584. save dottedarrow;
  585.  
  586. def dottedarrow(expr tl,hd,dlen,
  587.   slen,hlen) =
  588.  dottedline(tl,hd,dlen,slen);
  589.  headpath((tl..hd) transformed ztr,hlen);
  590. enddef;
  591.  
  592. % axes and axis marks
  593.  
  594. save axes;
  595.  
  596. def axes(expr hlen) =
  597.  arrow((0,yneg),(0,ypos),hlen);
  598.  arrow((xneg,0),(xpos,0),hlen);
  599. enddef;
  600.  
  601. save xmarks;
  602.  
  603. def xmarks(expr len)(text t) =
  604.  for a=t:
  605.   draw (xconv(a),yconv(0)-(len/2))..
  606.     (xconv(a),yconv(0)+(len/2));
  607.  endfor;
  608. enddef;
  609.  
  610. save ymarks;
  611.  
  612. def ymarks(expr len)(text t) =
  613.  for a=t:
  614.   draw (xconv(0)-(len/2),yconv(a))..
  615.     (xconv(0)+(len/2),yconv(a));
  616.  endfor;
  617. enddef;
  618.  
  619. % upright rectangles
  620.  
  621. save mkrect;
  622.  
  623. vardef mkrect(expr ll,ur) =
  624.  ll--(xpart ll,ypart ur)--
  625.    ur--(xpart ur,ypart ll)--cycle
  626. enddef;
  627.  
  628. save rect;
  629.  
  630. def rect(expr ll,ur) =
  631.  draw mkrect(ll,ur) transformed ztr;
  632. enddef;
  633.  
  634. save dottedrect;
  635.  
  636. def dottedrect(expr ll,ur,dlen,slen) =
  637.  dottedline(ll,(xpart ll,ypart ur),
  638.    dlen,slen);
  639.  dottedline((xpart ll,ypart ur),ur,
  640.    dlen,slen);
  641.  dottedline(ur,(xpart ur,ypart ll),
  642.    dlen,slen);
  643.  dottedline((xpart ur,ypart ll),ll,
  644.    dlen,slen);
  645. enddef;
  646.  
  647. save block;
  648.  
  649. def block(expr ll,ur) =
  650.  fill mkrect(ll,ur) transformed ztr;
  651. enddef;
  652.  
  653. % gt - rectshade now uses shade.
  654.  
  655. save rectshade;
  656.  
  657. def rectshade(expr sp,ll,ur) =
  658.   shade (sp) mkrect (ll, ur);
  659. enddef;
  660.  
  661. % circles and ellipses
  662.  
  663. save mkellipse;
  664.  
  665. vardef mkellipse(expr center,radx,rady,
  666.   angle) =
  667.  save t;
  668.  transform t;
  669.  t := identity
  670.    xscaled (2 * radx)
  671.    yscaled (2 * rady)
  672.    rotated angle
  673.    shifted center;
  674.  fullcircle transformed t
  675. enddef;
  676.  
  677. save ellipse;
  678.  
  679. def ellipse(expr center,radx,rady,
  680.   angle) =
  681.  draw
  682.    mkellipse(center,radx,rady,angle)
  683.    transformed ztr;
  684. enddef;
  685.  
  686. save circle;
  687.  
  688. def circle(expr center,rad) =
  689.  ellipse(center,rad,rad,0);
  690. enddef;
  691.  
  692. % gt - ellshade now uses shade.
  693.  
  694. save ellshade;
  695.  
  696. def ellshade (expr sp, center,
  697.   radx, rady, angle) =
  698.  shade (sp)
  699.    mkellipse (center, radx, rady, angle);
  700. enddef;
  701.  
  702. save circshade;
  703.  
  704. def circshade(expr sp, center,rad) =
  705.  ellshade(sp,center,rad,rad,0);
  706. enddef;
  707.  
  708. % circular arcs
  709.  
  710. % gt - mkarc now calculates
  711. % n using ceiling, not floor;
  712. % and saves theta, not i.
  713.  
  714. save mkarc;
  715.  
  716. vardef mkarc(expr center,from,sweep) =
  717.  pair p,q;
  718.  path f;
  719.  if sweep=0: f:=from
  720.  else:
  721.   n:=floor(abs(sweep)/45)+1;
  722.   if n<3: n:=3; fi;
  723.   theta:=sweep/(n-1);
  724.   f:=p:=from;
  725.   for i:=2 upto n:
  726.    p:=p rotatedabout (center,theta);
  727.    q:=p-center; q:=q rotated 90;
  728.    if theta<0: q:=-q; fi;
  729.    f:=f..p{unitvector q};
  730.   endfor;
  731.  fi;
  732.  f
  733. enddef;
  734.  
  735.  
  736. % gt - note that when sweep is a multiple
  737. % of 360 degrees, disp is logically
  738. % infinite, not zero; then the center is
  739. % at infinity.  In practice, arccenter
  740. % ought not to be called in that case.
  741.  
  742. save arccenter;
  743.  
  744. vardef arccenter(expr from,to,sweep)=
  745.  if from=to:
  746.    from
  747.  else:
  748.    pair midpt;
  749.    midpt:=(0.5)[from,to];
  750.    if (sweep mod 360)=0:
  751.      midpt
  752.    else:
  753.      disp:=cosd(sweep/2)/sind(sweep/2);
  754.      midpt+(disp*((to-from) rotated 90)/2)
  755.    fi
  756.  fi
  757. enddef;
  758.  
  759. % gt - mkarcto makes an arc given two points
  760. % on the arc and the sweep angle.
  761. % If sweep is a multiple of 360 degrees,
  762. % then the arc is a straight line;
  763. % if sweep is also nonzero, then that
  764. % line should be infinite, but I use
  765. % from--to instead.
  766.  
  767. save mkarcto;
  768.  
  769. vardef mkarcto(expr from,to,sweep) =
  770.  pair center;
  771.  center:=arccenter(from,to,sweep);
  772.  (mkarc(center, from, sweep))
  773. enddef;
  774.  
  775. % gt - arc now uses mkarcto.
  776.  
  777. save arc;
  778.  
  779. def arc(expr from,to,sweep) =
  780.  draw mkarcto (from, to, sweep)
  781.     transformed ztr;
  782. enddef;
  783.  
  784. % gt - arcarrow now uses mkarcto
  785. %      and arrowpath.
  786.  
  787. save arcarrow;
  788.  
  789. def arcarrow(expr hlen,from,to,sweep) =
  790.   arrowpath (hlen) mkarcto (from, to, sweep);
  791. enddef;
  792.  
  793. % gt - mkchordto makes a cyclic path from
  794. % the arc from "from" to "to" with a sweep
  795. % angle of "sweep", and its chord from
  796. % "to" to "from".
  797.  
  798. save mkchordto;
  799.  
  800. vardef mkchordto (expr from, to, sweep) =
  801.   mkarcto (from, to, sweep) -- cycle
  802. enddef;
  803.  
  804. % gt - arcshade now uses mkchordto
  805. %      and shade.
  806.  
  807. save arcshade;
  808.  
  809. def arcshade(expr sp,from,to,sweep) =
  810.   shade (sp) mkchordto (from, to, sweep);
  811. enddef;
  812.  
  813. % gt - three-point arcs.
  814.  
  815. save mkarcthree;
  816.  
  817. vardef mkarcthree (expr first, second, third) =
  818.  sweep:=2*(angle(third-second)-angle(second-first));
  819.  sweep:=sweep mod 720;
  820.  if sweep > 360: sweep:=sweep-720; fi
  821.  critical:=5;
  822.  if abs(sweep) <= critical:  % center may blow out
  823.   pair p[]; p1:=first; p2:=second; p3:=third;
  824.   mkpath(true,false,3,p)
  825.  else:
  826.   pair m[], d[], center;
  827.   m1:=(0.5)[first,second]; d1:=(second-first) rotated 90;
  828.   m2:=(0.5)[second,third]; d2:=(third-second) rotated 90;
  829.   center = m1+whatever*d1 = m2+whatever*d2;
  830.   mkarc(center,first,sweep)
  831.  fi
  832. enddef;
  833.  
  834. save arcthreecenter;
  835.  
  836. vardef arcthreecenter (expr first, mid, last) =
  837.   save c, m, d;
  838.   pair c, m[], d[];
  839.   d1 := (mid - first) rotated 90;
  840.   d2 := (last - mid) rotated 90;
  841.   m1 := 0.5 [first, mid];
  842.   m2 := 0.5 [mid, last];
  843.   c = m1 + whatever * d1 = m2 + whatever * d2;
  844.   c
  845. enddef;
  846.  
  847. save arcthree;
  848.  
  849. def arcthree (expr first, mid, last) =
  850.   draw mkarcthree (first, mid, last) transformed ztr;
  851. enddef;
  852.  
  853. save arcthreearrow;
  854.  
  855. def arcthreearrow (expr hlen, first, mid, last) =
  856.   arrowpath (hlen) mkarcthree (first, mid, last);
  857. enddef;
  858.  
  859. % modified polar coordinates
  860.  
  861. % gt - mklinedir makes a path from point "a"
  862. % to a point displaced "len" in direction "theta"
  863. % from "a".
  864.  
  865. save mklinedir;
  866.  
  867. vardef mklinedir (expr a, theta, len) =
  868.   a -- (a + len * (dir theta))
  869. enddef;
  870.  
  871. % gt - linedir now uses mklinedir.
  872.  
  873. save linedir;
  874.  
  875. def linedir(expr a,theta,len) =
  876.   draw mklinedir (a, theta, len)
  877.      transformed ztr;
  878. enddef;
  879.  
  880. % gt - arrowdir now uses mklinedir
  881. %      and arrowpath.
  882.  
  883. save arrowdir;
  884.  
  885. def arrowdir(expr hlen,a,theta,len) =
  886.  arrowpath (hlen)
  887.      mklinedir (a, theta, len);
  888. enddef;
  889.  
  890. % gt - mkarcth makes an arc path with
  891. % given center, radius "rad", initial
  892. % angle "frtheta", and final angle
  893. % "totheta".
  894.  
  895. save mkarcth;
  896.  
  897. vardef mkarcth (expr center,
  898.     frtheta, totheta, rad) =
  899.   save from;
  900.   pair from;
  901.   from := center + rad * (dir frtheta);
  902.   mkarc (center, from, totheta-frtheta)
  903. enddef;
  904.  
  905. % gt - arcth now uses mkarcth.
  906.  
  907. save arcth;
  908.  
  909. def arcth(expr center,
  910.   frtheta,totheta,rad) =
  911.   draw mkarcth (center, frtheta,
  912.         totheta, rad)
  913.     transformed ztr;
  914. enddef;
  915.  
  916. % gt - arcth now uses mkarcth
  917. %      and arrowpath.
  918.  
  919. save arctharrow;
  920.  
  921. def arctharrow(expr hlen,center,
  922.   frtheta,totheta,rad) =
  923.  arrowpath (hlen)
  924.      mkarcth (center, frtheta,
  925.               totheta, rad);
  926. enddef;
  927.  
  928. % gt - mkwedge makes a wedge-shaped path
  929. % with apex at "center", radius "rad",
  930. % initial angle "frtheta", and final angle
  931. % "totheta".
  932.  
  933. save mkwedge;
  934.  
  935. vardef mkwedge (expr center, frtheta, totheta, rad) =
  936.   center -- mkarcth (from, frtheta, totheta, rad)
  937.          -- cycle
  938. enddef;
  939.  
  940. % gt - wedge draws a sector of a circle.
  941.  
  942. save wedge;
  943.  
  944. def wedge (expr center, frtheta, totheta, rad) =
  945.   draw mkwedge (center, frtheta, totheta, rad)
  946.     transformed ztr;
  947. enddef;
  948.  
  949. % gt - wedgeshade now uses mkwedge and shade.
  950.  
  951. save wedgeshade;
  952.  
  953. def wedgeshade (expr sp, center,
  954.   frtheta, totheta, rad) =
  955.   shade (sp) mkwedge (center, frtheta, totheta, rad);
  956. enddef;
  957.  
  958. % gt - drawshadewedge draws and shades a wedge.
  959.  
  960. save drawshadewedge;
  961.  
  962. def drawshadewedge (expr sp, center,
  963.   frtheta, totheta, rad) =
  964.  draw mkwedge (center, frtheta, totheta, rad)
  965.    transformed ztr;
  966.  shade (sp) mkwedge (center, frtheta, totheta, rad);
  967. enddef;
  968.  
  969. % curves
  970.  
  971. % gt - watch out for that "text containing a local
  972. % variable's name" conflict!  I dearly wish that
  973. % weren't a danger.
  974. % Perhaps it's not so likely at the level of "mkcurve",
  975. % as the "mk" macros are often fed numeric constants.
  976.  
  977. save mkcurve;
  978.  
  979. vardef mkcurve(expr smooth,cyclic)
  980.   (text t) =
  981.  save n_, p_;
  982.  pair p_[];
  983.  textpairs (t) (p_, n_);
  984.  mkpath(smooth,cyclic,n_,p_)
  985. enddef;
  986.  
  987. save curve;
  988.  
  989. def curve(expr smooth,cyclic)
  990.   (text t) =
  991.  draw mkcurve(smooth,cyclic,t)
  992.    transformed ztr;
  993. enddef;
  994.  
  995. % gt - curvedarrow now uses arrowpath.
  996.  
  997. save curvedarrow;
  998.  
  999. def curvedarrow(expr smooth,hlen)
  1000.   (text t) =
  1001.   arrowpath (hlen)
  1002.       mkcurve (smooth, false, t);
  1003. enddef;
  1004.  
  1005. % shading of cyclic curves
  1006.  
  1007. % gt - cycleshade now uses shade.
  1008.  
  1009. save cycleshade;
  1010.  
  1011. def cycleshade(expr sp,smooth)(text t) =
  1012.   shade (sp) mkcurve (smooth,true,t);
  1013. enddef;
  1014.  
  1015. % gt - interpolated splines with controls.
  1016.  
  1017. % gt - mkipath uses the interpolation points,
  1018. % p[], and the left and right control points,
  1019. % l[] and r[].
  1020. % Observe that for cyclic I-splines, l[n] is
  1021. % used, not l1, though they are equal; this
  1022. % simplifies the algorithm.
  1023.  
  1024. save mkipath;
  1025.  
  1026. vardef mkipath (expr closed, n)
  1027.   (suffix p, l, r) =
  1028.   for i=1 upto n-1:
  1029.     p[i]..controls r[i] and l[i+1]..
  1030.   endfor
  1031.   if closed:
  1032.     cycle
  1033.   else:
  1034.     p[n]
  1035.   fi
  1036. enddef;
  1037.  
  1038. % gt - mkisplineA uses the I-spline data,
  1039. % in the order that Fig 2.1 gives them,
  1040. % points line pl and control line cl,
  1041. % stores them in p[], l[] and r[],
  1042. % then calls mkipath.
  1043. %
  1044. % pl should have the form:
  1045. %   (x1,y1) ... (xn,yn)
  1046. % and cl the form:
  1047. %   (lx1,ly1) (rx1,ry1) ... (lxn,lyn) (rxn,ryn)
  1048. % which reflect how Fig outputs its data.
  1049. %
  1050. % Don't feed it the "9999 9999", please!
  1051. %
  1052. % Perhaps the input should be massaged by a
  1053. % preprocessor program (e.g. in C), to separate
  1054. % the initially interleaved left and right control
  1055. % points, before being given to graphbase?
  1056. % That would simplify mkisplineA, and run faster.
  1057.  
  1058. save mkisplineA;
  1059.  
  1060. vardef mkisplineA (expr closed)
  1061.   (text pl) (text cl) =
  1062.   save p, l, r, n, i, isleft;
  1063.   pair p[], l[], r[];
  1064.   boolean isleft;
  1065.   textpairs (pl) (p, n);
  1066.   i := 1;
  1067.   isleft := true;
  1068.   for b=cl:
  1069.     if isleft:
  1070.       l[i] := b;
  1071.       isleft := false;
  1072.     else:
  1073.       r[i] := b;
  1074.       i := i+1;
  1075.       isleft := true;
  1076.     fi;
  1077.   endfor;
  1078.   mkipath (closed, n, p, l, r)
  1079. enddef;
  1080.  
  1081. % gt - mkisplineB uses the points line,
  1082. % and the separated left and right controls.
  1083. %
  1084. % See how much simpler this is than
  1085. % mkisplineA.
  1086.  
  1087. save mkisplineB;
  1088.  
  1089. vardef mkisplineB (expr closed)
  1090.   (text pl) (text lc) (text rc) =
  1091.   save p, l, r, n, i;
  1092.   pair p[], l[], r[];
  1093.   textpairs (pl) (p, n);
  1094.   textpairs (lc) (l, i);
  1095.   textpairs (rc) (r, i);
  1096.   mkipath (closed, n, p, l, r)
  1097. enddef;
  1098.  
  1099. % gt - the usual variations.
  1100. %
  1101. % These use mkisplineA.  I'd prefer
  1102. % mkisplineB.
  1103.  
  1104. % draw an interpolated spline,
  1105. % with points line pl and interleaved
  1106. % control line cl.
  1107.  
  1108. save ispline;
  1109.  
  1110. def ispline (expr closed)
  1111.   (text pl) (text cl) =
  1112.   draw mkisplineA (closed) (pl) (cl)
  1113.     transformed ztr;
  1114. enddef;
  1115.  
  1116. save isplinearrow;
  1117.  
  1118. def isplinearrow (expr hlen, closed)
  1119.   (text pl) (text cl) =
  1120.   arrowpath (hlen)
  1121.       mkisplineA (closed) (pl) (cl);
  1122. enddef;
  1123.  
  1124. % gt - isplineshade assumes that the
  1125. % I-spline is closed.
  1126.  
  1127. save isplineshade;
  1128.  
  1129. def isplineshade (expr sp)
  1130.   (text pl) (text cl) =
  1131.   shade (sp)
  1132.       mkisplineA (true) (pl) (cl);
  1133. enddef;
  1134.  
  1135. % functions
  1136.  
  1137. % gt - better be on the safe side with
  1138. % the function text, so use "_" on local
  1139. % variables in "mkfcn".
  1140.  
  1141. save mkfcn;
  1142.  
  1143. vardef mkfcn(expr smooth,bmin,bmax,bst)
  1144.   (suffix bv)(text fcnpr) =
  1145.  save p_, i_;
  1146.  pair p_[];
  1147.  i_ := 0;
  1148.  for bv=bmin step bst
  1149.    until bmax+(bst/2):
  1150.   p_[incr i_] := fcnpr;
  1151.  endfor;
  1152.  mkpath (smooth, false, i_ , p_)
  1153. enddef;
  1154.  
  1155. save function;
  1156.  
  1157. def function(expr smooth,xmin,xmax,st)
  1158.   (text fx) =
  1159.  draw mkfcn (smooth, xmin, xmax, st,
  1160.    x, (x,fx))
  1161.    transformed ztr;
  1162. enddef;
  1163.  
  1164. save parafcn;
  1165.  
  1166. def parafcn(expr smooth,tmin,tmax,st)
  1167.   (text ft) =
  1168.  draw mkfcn (smooth, tmin, tmax, st,
  1169.    t, ft)
  1170.    transformed ztr;
  1171. enddef;
  1172.  
  1173. % gt - mksfn constructs a path from
  1174. % two functions and the verticals
  1175. % at either side.
  1176. %
  1177. % mksfn is used by shadefcn.
  1178.  
  1179. save mksfn;
  1180.  
  1181. vardef mksfn (expr smooth, xmin, xmax, st)
  1182.     (text fcni) (text fcnii) =
  1183.   mkfcn(smooth,xmin,xmax,st,x,(x,fcni))
  1184.   --
  1185.   reverse
  1186.   mkfcn(smooth,xmin,xmax,st,x,(x,fcnii))
  1187.   -- cycle
  1188. enddef;
  1189.  
  1190. % gt - description:
  1191. % shadefcn shades between two functions over
  1192. % the range xmin to xmax, stepping by st,
  1193. % with dot spacing sp.
  1194. % it does not draw the functions.
  1195.  
  1196. % gt - shadefcn now uses mksfn.
  1197. % I don't see the connection between the dot
  1198. % spacing sp and the function step size st.
  1199.  
  1200. save shadefcn, st;
  1201.  
  1202. def shadefcn(expr sp, xmin, xmax)
  1203.     (text fcni)(text fcnii) =
  1204.   st := unxconv (sp);
  1205.   shade (sp)
  1206.     mksfn (false, xmin, xmax, st) (fcni) (fcnii);
  1207. enddef;
  1208.  
  1209. % gt - drawshadefcn draws both functions fcni
  1210. % and fcnii, and shades between them.
  1211.  
  1212. save drawshadefcn;
  1213.  
  1214. def drawshadefcn (expr sp, smooth, xmin, xmax, st)
  1215.     (text fcni) (text fcnii) =
  1216.   function (smooth, xmin, xmax, st) (fcni);
  1217.   function (smooth, xmin, xmax, st) (fcnii);
  1218.   shadefcn (sp, xmin, xmax) (fcni) (fcnii);
  1219. enddef;
  1220.  
  1221. enddef;  % mfpicenv
  1222.  
  1223. def endmfpicenv =
  1224.  endgroup;
  1225. enddef;
  1226.  
  1227.  
  1228. % end graphbase.mf
  1229.